home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 20 / Cream of the Crop 20 (Terry Blount) (1996).iso / comm / cpt152.zip / CPT-S152.ZIP / CPT_CODE.PAS next >
Pascal/Delphi Source File  |  1996-05-16  |  36KB  |  1,139 lines
  1. {$N-,E- no math support needed}
  2. {$X- function calls may not be discarded}
  3. {$I- disable I/O checking (trap errors by checking IOResult)}
  4.  
  5. UNIT CPT_CODE;
  6. INTERFACE
  7.  
  8. {$IFDEF DPMI}
  9.   USES DOS, NUMDAYS, ARCID;
  10. {$ELSE}
  11.   USES DOS, NUMDAYS, ARCID, HEAPMAN;
  12. {$ENDIF}
  13.  
  14. TYPE
  15.   MemLink = ^MemberRec;
  16.   MemberRec = RECORD
  17.                 Name   : STRING [25];
  18.                 sent   : WORD;
  19.                 oldest,
  20.                 newest : STRING [8];
  21.                 BBS1,
  22.                 BBS2   : STRING [79];
  23.                 notes  : STRING [79];
  24.                 next   : MemLink;
  25.               END;
  26.  
  27. CONST
  28.   version = ' v1.52 ';
  29.   author  = 'Copyright (c) May 16th, 1996, by David Daniel Anderson - Reign Ware.';
  30.  
  31.   OldDelimitLine = '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=' +
  32.                    '-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=';
  33.  
  34.   DelimitLine = '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' +
  35.                 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~';
  36.  
  37.   EndOfDB = '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>' +
  38.                  ' end of database ' +
  39.             '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
  40.  
  41.   High_Message : STRING [7] = '';
  42.  
  43.   cursorState : BYTE = 1;  {0..3}
  44.   cursorData : ARRAY [0..3] OF CHAR = (#179, #47, #196, #92);
  45.  
  46.   DATFileName = 'MESSAGES.DAT';
  47.   CNFFileName = 'CONTROL.DAT';
  48.   lf = #13#10;
  49.  
  50. VAR confnumb : WORD;
  51.   field    : STRING;
  52.   inverse  : BOOLEAN;
  53.  
  54. VAR
  55.   unQWK, unARC, unARJ, unHAP, unLHA,
  56.   unPAK, unRAR, unUC2, unZIP, unZOO : PATHSTR;
  57.   ExCMD : PATHSTR;
  58.  
  59.   CheckFROM,
  60.   Validate,
  61.   TrackPrivate : BOOLEAN;
  62.   CONFname : STRING [25];
  63.  
  64. {===========================================================================}
  65.  
  66. PROCEDURE WriteError (CONST problem: BYTE);
  67. FUNCTION WordToHex (i: WORD): STRING;
  68. PROCEDURE CheckIO;
  69. PROCEDURE cursorOff;
  70. PROCEDURE cursorOn;
  71. PROCEDURE updateCursor;
  72. FUNCTION WhereX: BYTE;
  73. FUNCTION WhereY: BYTE;
  74. PROCEDURE GotoXY (X, Y: BYTE);
  75. PROCEDURE WriteCharAtCursor (X: CHAR);
  76. PROCEDURE ClrEol;
  77. PROCEDURE WriteMemAvail;
  78. FUNCTION IsFile (CONST FileName: PATHSTR): BOOLEAN;
  79. PROCEDURE EraseFile (CONST FileName : STRING);
  80. (* PROCEDURE UpFast (VAR Str: STRING);  {** from SWAG **} *)
  81. FUNCTION UpStr (lstr : STRING): STRING;
  82. FUNCTION LowerStr (w: STRING): STRING;
  83. FUNCTION MixCase (s: STRING): STRING;
  84. FUNCTION RTrim (InStr: STRING): STRING;
  85. FUNCTION LTrim (InStr: STRING): STRING;
  86. FUNCTION Squeeze (ss: STRING): STRING;
  87. Function LongIntDays (DayStr: String): LongInt;
  88. FUNCTION GetNewHigh (High, current: STRING): STRING;
  89. FUNCTION MiddleOf (CONST s: STRING): STRING;
  90. FUNCTION GetOriginLine (ol : STRING): STRING;
  91. FUNCTION GetConfNUMBER (CONST PSTR: STRING): PATHSTR;
  92. FUNCTION IsDir (CONST FileName: PATHSTR): BOOLEAN;
  93. FUNCTION GetFilePath (CONST PSTR: STRING; VAR sDir: DIRSTR): PATHSTR;
  94. FUNCTION GetCONFname (CONST QWKpath, CNFFileName: STRING): STRING;
  95. FUNCTION BuildList (VAR list: MemLink; CONST fname: STRING): WORD;
  96. FUNCTION ReadDAT (VAR list: MemLink; CONST DATFileName: STRING): WORD;
  97. FUNCTION Relevant (CONST s: STRING; CONST len: BYTE): STRING;
  98. PROCEDURE GetSortField (CONST PSTR: STRING);
  99. FUNCTION CompareFields (CONST cnode, cnode2: MemLink): BOOLEAN;
  100. PROCEDURE SortLinkedList (VAR list: MemLink);  {By Ian Lin, found in SWAG}
  101. PROCEDURE WriteList (VAR list: MemLink; CONST fname: STRING; CONST mems: WORD);
  102. PROCEDURE WriteStats (VAR list: MemLink; CONST fname: STRING; CONST mems: WORD);
  103. PROCEDURE InitCONFIG;
  104. FUNCTION IsArchive (CONST SomeFile: PATHSTR): PATHSTR;
  105. FUNCTION ExtractFile (CONST ArchiveFile, FileToEx: PATHSTR; ExCMD: PATHSTR): BOOLEAN;
  106.  
  107. {===========================================================================}
  108.  
  109. IMPLEMENTATION
  110.  
  111. PROCEDURE WriteError (CONST problem: BYTE);
  112. VAR
  113.   message: STRING [79];
  114. BEGIN
  115.   CASE problem OF
  116.     1 : message := 'Invalid parameter on command line or parameter missing.';
  117.     2 : message := 'No files found.  First parameter must be a valid file specification.';
  118.     3 : message := 'You cannot use ".STT" as the file extension, since .STT is used by CPT-Stat.';
  119.  
  120. (*  Numbers 4 and 5 are -possible- reasons for aborting, but I've chosen not to.  *)
  121.  
  122. (*  4 : message := 'Configuration file not found with executable.  Consult the documentation.'; *)
  123. (*  5 : message := 'Unable to run unarchiver!  Aborting.';                                      *)
  124.  
  125.     6 : message := 'You cannot just specify a path, add "*.*" or "\*.*" for all files.';
  126.     7 : message := 'File handling error.  Original has not been updated, and is possibly corrupt.';
  127.     8 : message := 'This database was corrupted by CPT v1.36, read the "CPT-Fix.DOC" file for help.';
  128.     ELSE  message := 'Unknown error.';
  129.   END;
  130.   WriteLn (#7, 'Error encountered, number ', problem, ':'); WriteLn (message);
  131. END;
  132.  
  133. FUNCTION WordToHex (i: WORD): STRING; {Convert a WORD variable to STRING}
  134. CONST
  135.   HexLetters : ARRAY [0..15] OF CHAR = '0123456789ABCDEF';
  136. BEGIN
  137.   WordToHex := Concat (HexLetters [Hi (i) SHR 4], HexLetters [Hi (i) AND 15],
  138.                        HexLetters [Lo (i) SHR 4], HexLetters [Lo (i) AND 15]);
  139. END;
  140.  
  141. PROCEDURE CheckIO;
  142. BEGIN
  143.   IF IOResult <> 0 THEN Halt (7);
  144. END;
  145.  
  146. PROCEDURE cursorOff; ASSEMBLER;
  147. (* Routine from SWAG *)
  148. ASM
  149.   mov AH, 3; mov BH, 0; Int $10; OR CH, $20; mov AH, 1; Int $10;
  150. END;
  151.  
  152. PROCEDURE cursorOn; ASSEMBLER;
  153. (* Routine from SWAG *)
  154. ASM
  155.   mov AH, 3; mov BH, 0; Int $10; AND CH, NOT $20; mov AH, 1; Int $10;
  156. END;
  157.  
  158. PROCEDURE updateCursor;
  159. BEGIN
  160.   cursorState := Succ (cursorState) AND 3;
  161.   Write (cursorData [cursorState], ^H);
  162. END;
  163.  
  164. FUNCTION WhereX: BYTE; ASSEMBLER;
  165. (* Routine from SWAG *)
  166. ASM
  167.   MOV AH, 3     {Ask For current cursor position}
  168.   MOV BH, 0     { On page 0 }
  169.   Int 10h       { Return inFormation in DX }
  170.   Inc DL        { Bios Assumes Zero-based. Crt.WhereX Uses 1 based }
  171.   MOV AL, DL    { Return X position in AL For use in Byte Result }
  172. END;
  173.  
  174. FUNCTION WhereY: BYTE; ASSEMBLER;
  175. (* Routine from SWAG *)
  176. ASM
  177.   MOV AH, 3    {Ask For current cursor position}
  178.   MOV BH, 0    { On page 0 }
  179.   Int 10h      { Return inFormation in DX }
  180.   Inc DH       { Bios Assumes Zero-based. Crt.WhereY Uses 1 based }
  181.   MOV AL, DH   { Return Y position in AL For use in Byte Result }
  182. END;
  183.  
  184. PROCEDURE GotoXY (X, Y: BYTE); ASSEMBLER;
  185. (* Routine from SWAG *)
  186. ASM
  187.   MOV DH, Y    { DH = Row (Y) }
  188.   MOV DL, X    { DL = Column (X) }
  189.   Dec DH       { Adjust For Zero-based Bios routines }
  190.   Dec DL       { Turbo Crt.GotoXY is 1-based }
  191.   MOV BH, 0    { Display page 0 }
  192.   MOV AH, 2    { Call For SET CURSOR POSITION }
  193.   Int 10h
  194. END;
  195.  
  196. PROCEDURE WriteCharAtCursor (X: CHAR);
  197. (* Routine from SWAG *)
  198. VAR
  199.   reg: REGISTERS;
  200. BEGIN
  201.   reg. AH := $0A;
  202.   reg. AL := Ord (X);
  203.   reg. BH := $00;    {* Display Page Number. * for Graphics Modes! *}
  204.   reg. CX := 1;      {* Word for number of characters to write *}
  205.   Intr ($10, reg);
  206. END;
  207.  
  208. PROCEDURE ClrEol;
  209. (* Routine by DDA *)
  210. VAR
  211.   NumCol: WORD ABSOLUTE $0040: $004A; { Number of CRT columns (1-based) }
  212.   X, Y, DistanceToRight: BYTE;
  213. BEGIN
  214.   X := WhereX;
  215.   Y := WhereY;
  216.   DistanceToRight := NumCol - X;
  217.   Write ('': DistanceToRight);
  218.   WriteCharAtCursor (#32);
  219.   GotoXY (X, Y);
  220. END;
  221.  
  222. PROCEDURE WriteMemAvail;
  223. BEGIN
  224.   GotoXY (60, WhereY);
  225.   WriteLn ('Free RAM: ', MemAvail);
  226. END;
  227.  
  228. FUNCTION IsFile (CONST FileName: PATHSTR): BOOLEAN;
  229. VAR
  230.   Attr  : WORD;
  231.   cFile : FILE;
  232. BEGIN
  233.   Assign (cFile, FileName);
  234.   GetFAttr (cFile, Attr);
  235.   IF (DosError = 0) AND ((Attr AND Directory) <> Directory)
  236.     THEN IsFile := TRUE
  237.     ELSE IsFile := FALSE;
  238. END;
  239.  
  240. PROCEDURE EraseFile (CONST FileName : STRING);
  241. VAR
  242.   cFile : FILE;
  243. BEGIN
  244.   IF IsFile (FileName) THEN BEGIN
  245.     Assign (cFile, FileName);
  246.     SetFAttr (cFile, 0);
  247.     Erase (cFile); CheckIO;
  248.   END;
  249. END;
  250.  
  251. PROCEDURE UpFast (VAR Str: STRING);  {** from SWAG **}
  252. INLINE ($8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('a')/Ord('z')/
  253.         $AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$6C/$FF/$20/$E2/$F1/$8E/$DA);
  254.  
  255. FUNCTION UpStr (lstr : STRING): STRING;
  256. BEGIN
  257.   upfast (lstr);
  258.   UpStr := lstr;
  259. END;
  260.  
  261. FUNCTION LowerStr (w: STRING): STRING;
  262. VAR
  263.   cp  : INTEGER;        {T